perm filename QSUBST.LSP[QLA,LSP] blob sn#841074 filedate 1987-06-03 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(defmacro lock-cons (x y)
C00004 ENDMK
CāŠ—;
(defmacro lock-cons (x y)
 `(prog2 (get-lock *cons-lock*)
	 (cons ,x ,y)
	 (release-lock *cons-lock*)))

(defun init (m n atoms)
       (let ((atoms (subst () () atoms)))
	    (do ((a atoms (cdr a)))
		((null (cdr a)) (setf (cdr a) atoms)))
	    (init1 m n atoms)))

(defun init1 (m n atoms)
       (cond ((= m 0) (pop atoms))
	     (t (do ((i n (- i 2))
		     (a ()))
		    ((< i 1) a)
		    (push (pop atoms) a)
		    (push (init1 (1- m) n atoms) a)))))

(defun bin-init (depth one other)
 (cond ((zerop depth) one)
       (t (cons (bin-init (1- depth) other one)
		(bin-init (1- depth) other one)))))

(defun sbst (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet nil ((q (sbst x y (car z)))
		   (r (sbst x y (cdr z))))
	      (lock-cons q r)))))

(defun qsubst (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet t ((q (qsubst x y (car z)))
		 (r (qsubst x y (cdr z))))
	      (lock-cons q r)))))


(defun qsubst2 (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet t ((q (sbst x y (car z)))
		 (r (sbst x y (cdr z))))
	      (lock-cons q r)))))